home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / arith.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  40KB  |  1,527 lines
  1. /* ******************************************************************** */
  2. /*  arith.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  arithmetic                                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: arith.c,v 1.5 1992/05/28 11:19:01 pab Exp $
  9.  *
  10.  * $Log: arith.c,v $
  11.  * Revision 1.5  1992/05/28  11:19:01  pab
  12.  * fix
  13.  *
  14.  * Revision 1.5  1992/01/09  19:10:38  pab
  15.  * Fixed for low tagged ints
  16.  *
  17.  * Revision 1.4  1991/12/22  15:13:47  pab
  18.  * Xmas revision
  19.  *
  20.  * Revision 1.3  1991/09/22  19:14:32  pab
  21.  * Fixed obvious bugs
  22.  *
  23.  * Revision 1.2  1991/09/11  11:59:29  pab
  24.  * 11/9/91 First Alpha release of modified system
  25.  *
  26.  * Revision 1.1  1991/08/12  16:49:24  pab
  27.  * Initial revision
  28.  *
  29.  * Revision 1.19  1991/03/05  19:49:29  pab
  30.  * added sqrt function
  31.  *
  32.  * Revision 1.18  1991/02/13  18:15:15  kjp
  33.  * Somethign good + RCS log headers.
  34.  *
  35.  */
  36.  
  37. /*
  38.  * Change Log:
  39.  *   Version 1, May 1989
  40.  */
  41.  
  42. #include "defs.h"
  43. #include "structs.h"
  44. #include "error.h"
  45. #include "funcalls.h"
  46.  
  47. #include "global.h"
  48. #include <math.h>
  49.  
  50. extern int abs(int);
  51.  
  52. #include "ngenerics.h"
  53. #include "modboot.h"
  54.  
  55. EUFUN_1( Fn_numberp, a)
  56. {
  57.   return (typeof(a)>=TYPE_INT && typeof(a)<=TYPE_LASTNUMBER ? lisptrue : nil);
  58. }
  59. EUFUN_CLOSE
  60.  
  61. LispObject lift_number(LispObject *stackbase, int newtype)
  62. {
  63.   LispObject a = ARG_0(stackbase);
  64.   switch(typeof(a)) 
  65.     {
  66.     case TYPE_INT:
  67.       switch (newtype) 
  68.     {
  69.     case TYPE_RATIONAL:
  70.       { LispObject one = allocate_integer(stackbase+1, 1);
  71.         a = allocate_ratio(stackbase+1, ARG_0(stackbase),one);
  72.         return a;
  73.       }      
  74.     case TYPE_FLOAT:
  75.       return allocate_float(stackbase+1,(double) (intval(a)));
  76.     case TYPE_COMPLEX:
  77.       { LispObject zero = allocate_integer(stackbase+1, 0);
  78.         a = allocate_complex(stackbase+1,ARG_0(stackbase),zero);
  79.         return a;
  80.       }      
  81.     default:
  82.       CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  83.     }
  84.     case TYPE_RATIONAL:
  85.       switch (newtype) {
  86.       case TYPE_FLOAT: 
  87.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  88.       case TYPE_COMPLEX:
  89.     { LispObject zero = allocate_integer(stackbase+1, 0);
  90.       a = allocate_complex(stackbase+1,ARG_0(stackbase),zero);
  91.       return a;
  92.     }      
  93.       default:
  94.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  95.       }
  96.     case TYPE_FLOAT:
  97.       switch (newtype) {
  98.       case TYPE_COMPLEX:
  99.     { LispObject zero = allocate_integer(stackbase, 0);
  100.       return allocate_complex(stackbase,ARG_0(stackbase), zero);
  101.     }      
  102.       case TYPE_FLOAT:
  103.     return a;
  104.       default:
  105.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  106.       }
  107.     default:
  108.       CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  109.     }
  110.   return nil;
  111. }
  112.  
  113. EUFUN_2(Fn_eqn, a, b)
  114. {
  115.   if (typeof(a)>typeof(b)) {
  116.     LispObject tmp = a;
  117.     a = b;
  118.     b = tmp;
  119.   }
  120.                 /* types the same is easy!! */
  121.   switch ((typeof(a)<<16)+typeof(b)) {
  122.   case (TYPE_INT<<16)+TYPE_INT:
  123.     return ((intval(a)==intval(b)) ? a : nil);
  124.   case (TYPE_INT<<16)+TYPE_RATIONAL:
  125.   case (TYPE_INT<<16)+TYPE_COMPLEX:
  126.     return nil;
  127.   case (TYPE_INT<<16)+TYPE_FLOAT:
  128.     return (((double)intval(a) == (b->FLOAT).fvalue) ? b : nil);
  129.   case (TYPE_RATIONAL<<16)+TYPE_RATIONAL:
  130.     {
  131.       LispObject ans;
  132.       EUCALLSET_2(ans, Fn_eqn, (a->RATIO).numerator,(b->RATIO).numerator);
  133.       if (ans == nil) return nil;
  134.       EUCALLSET_2(ans, Fn_eqn, (a->RATIO).denominator,(b->RATIO).denominator);
  135.       if (ans == nil) return nil;
  136.       return ARG_0(stackbase);
  137.     }
  138.   case (TYPE_RATIONAL<<16)+TYPE_FLOAT:
  139.     CallError(stacktop,"Unimplemented comparison",a,NONCONTINUABLE);
  140.   case (TYPE_RATIONAL<<16)+TYPE_COMPLEX:
  141.     return nil;
  142.   case (TYPE_FLOAT<<16)+TYPE_FLOAT:
  143.     return ((a->FLOAT).fvalue == (b->FLOAT).fvalue ? a : nil);
  144.   case (TYPE_FLOAT<<16)+TYPE_COMPLEX:
  145.     return nil;
  146.   case (TYPE_COMPLEX<<16)+TYPE_COMPLEX:
  147.     {
  148.       LispObject ans;
  149.       EUCALLSET_2(ans, Fn_eqn, (a->COMPLEX).real,(b->COMPLEX).real);
  150.       if (ans == nil) return nil;
  151.       EUCALLSET_2(ans, Fn_eqn, (a->COMPLEX).imaginary,(b->COMPLEX).imaginary);
  152.       if (ans == nil) return nil;
  153.       return ARG_0(stackbase);
  154.     }
  155.   default:
  156.     CallError(stacktop,"Unimplemented comparison",a,NONCONTINUABLE);
  157.   }
  158.   return nil;
  159. }
  160. EUFUN_CLOSE
  161.  
  162. EUFUN_2(Fn_plus, a, b)
  163. {
  164.   if (typeof(a)>typeof(b)) {
  165.     LispObject tmp;
  166.     tmp = a; a = ARG_0(stackbase) = b; b = ARG_1(stackbase) = tmp;
  167.   }
  168.   if (typeof(a)!=typeof(b)) {
  169.     ARG_0(stacktop) = a;
  170.     a = lift_number(stacktop,typeof(b));
  171.     b = ARG_1(stackbase);
  172.   }
  173.   switch (typeof(a)) {
  174.   case TYPE_INT:
  175.     return allocate_integer(stacktop, intval(a) + intval(b));
  176.   case TYPE_RATIONAL:
  177.     CallError(stacktop,"Unimplemented facility in +",a,NONCONTINUABLE);
  178.   case TYPE_FLOAT:
  179.     return allocate_float(stacktop,(a->FLOAT).fvalue + (b->FLOAT).fvalue);
  180.   case TYPE_COMPLEX:
  181.     {
  182.       LispObject rr;
  183.       LispObject im;
  184.       EUCALLSET_2(rr, Fn_plus, (a->COMPLEX).real, (b->COMPLEX).real);
  185.       EUCALLSET_2(im, Fn_plus, (a->COMPLEX).imaginary, (b->COMPLEX).imaginary);
  186.       return allocate_complex(stacktop,rr,im);
  187.     }
  188.   default:
  189.     CallError(stacktop,"Unimplemented facility in +",a,NONCONTINUABLE);
  190.   }
  191.   return nil;
  192. }
  193. EUFUN_CLOSE
  194.  
  195. EUFUN_2(Fn_difference, a, b)
  196. {
  197.   if (typeof(a)!=typeof(b)) {
  198.     if (typeof(a)<typeof(b)) {
  199.       ARG_0(stacktop) = a;
  200.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  201.     }
  202.     else {
  203.       ARG_0(stacktop) = b;
  204.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  205.     }
  206.   }
  207.   switch (typeof(a)) {
  208.   case TYPE_INT:
  209.     return allocate_integer(stacktop, intval(a) - intval(b));
  210.   case TYPE_RATIONAL:
  211.     CallError(stacktop,"Unimplemented facility in -",a,NONCONTINUABLE);
  212.   case TYPE_FLOAT:
  213.     return allocate_float(stacktop,(a->FLOAT).fvalue - (b->FLOAT).fvalue);
  214.   case TYPE_COMPLEX:
  215.     {
  216.       LispObject rr;
  217.       LispObject im;
  218.       EUCALLSET_2(rr, Fn_difference, (a->COMPLEX).real,(b->COMPLEX).real);
  219.       EUCALLSET_2(im, Fn_difference,
  220.               (a->COMPLEX).imaginary,(b->COMPLEX).imaginary);
  221.       return allocate_complex(stacktop,rr,im);
  222.     }
  223.   default:
  224.     CallError(stacktop,"Unimplemented facility in -",a,NONCONTINUABLE);
  225.   }
  226.   return nil;
  227. }
  228. EUFUN_CLOSE
  229.  
  230. EUFUN_2(Fn_times, a, b)
  231. {
  232.   if (typeof(a)>typeof(b)) {
  233.     LispObject tmp;
  234.     tmp = a; a = ARG_0(stackbase) = b; b = ARG_1(stackbase) = tmp;
  235.   }
  236.   if (typeof(a)!=typeof(b)) {
  237.     ARG_0(stacktop) = a;
  238.     ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  239.   }
  240.   switch (typeof(a)) {
  241.   case TYPE_INT:
  242.     return allocate_integer(stacktop, intval(a) * intval(b));
  243.   case TYPE_RATIONAL:
  244.     {
  245.       LispObject num;
  246.       LispObject den;
  247.       EUCALLSET_2(num, Fn_times, (a->RATIO).numerator,(b->RATIO).numerator);
  248.       EUCALLSET_2(den, Fn_times,(a->RATIO).denominator,(b->RATIO).denominator);
  249.       return allocate_ratio(stackbase, num,den); /* Should reduce this */
  250.     }
  251.   case TYPE_FLOAT:
  252.     return allocate_float(stackbase,(a->FLOAT).fvalue * (b->FLOAT).fvalue);
  253.   case TYPE_COMPLEX:
  254.     CallError(stacktop,"Unimplemented facility in *",a,NONCONTINUABLE);
  255.   default:
  256.     CallError(stacktop,"Unimplemented facility in *",a,NONCONTINUABLE);
  257.   }
  258.   return nil;
  259. }
  260. EUFUN_CLOSE
  261.  
  262. EUFUN_2(Fn_divide, a, b)
  263. {
  264.   if (typeof(a)<typeof(b)) {
  265.       ARG_0(stacktop) = a;
  266.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  267.     }
  268.   else if (typeof(a)>typeof(b)) {
  269.       ARG_0(stacktop) = b;
  270.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  271.     }
  272.  
  273.   /* Types are equivalent... */
  274.  
  275.   switch(typeof(a)) {
  276.  
  277.   case TYPE_INT:
  278.     return((LispObject) allocate_integer(stackbase, intval(a) / intval(b)));
  279.   case TYPE_RATIONAL:
  280.     {
  281.       LispObject num;
  282.       LispObject den;
  283.       EUCALLSET_2(num, Fn_times,a->RATIO.numerator,b->RATIO.denominator);
  284.       EUCALLSET_2(den, Fn_times,a->RATIO.denominator,b->RATIO.numerator);
  285.       return(allocate_ratio(stackbase,num,den)); /* Not canonical... */
  286.     }
  287.   case TYPE_FLOAT:
  288.     return(allocate_float(stackbase,a->FLOAT.fvalue / b->FLOAT.fvalue));
  289.   case TYPE_COMPLEX:
  290.   default:
  291.     CallError(stacktop,"kernel /: unimplemented facility",a,NONCONTINUABLE);
  292.  
  293.   }
  294.  
  295.   return(nil);
  296. }
  297. EUFUN_CLOSE
  298.  
  299. EUFUN_2(Fn_lessp, a, b)
  300. {
  301.   if (typeof(a)!=typeof(b)) {
  302.   if (typeof(a)<typeof(b)) {
  303.       ARG_0(stacktop) = a;
  304.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  305.     }
  306.   else {
  307.       ARG_0(stacktop) = b;
  308.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  309.     }
  310.   }
  311.   switch (typeof(a)) {
  312.   case TYPE_INT:
  313.     return (intval(a) < intval(b) ? lisptrue : nil);
  314.   case TYPE_RATIONAL:
  315.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  316.   case TYPE_FLOAT:
  317.     return ((a->FLOAT).fvalue < (b->FLOAT).fvalue ? lisptrue : nil);
  318.   case TYPE_COMPLEX:
  319.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  320.   default:
  321.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  322.   }
  323.   return nil;
  324. }
  325. EUFUN_CLOSE
  326.  
  327. EUFUN_2(Fn_greaterp, a, b)
  328. {
  329.   if (Fn_lessp(stackbase) == nil && Fn_eqn(stackbase) == nil)
  330.     return(lisptrue);
  331.   else
  332.     return(nil);
  333. }
  334. EUFUN_CLOSE
  335.  
  336. LispObject generic_zerop;
  337.  
  338. EUFUN_1( Gf_zerop, i)
  339. {
  340.   return(generic_apply_1(stackbase, generic_zerop,i));
  341. }
  342. EUFUN_CLOSE
  343.  
  344. EUFUN_1( Fn_zerop, a)
  345. {
  346.   switch (typeof(a)) {
  347.   case TYPE_INT:
  348.     return (intval(a) == 0 ? lisptrue : nil);
  349.   case TYPE_BIGNUM:
  350.     return nil;
  351.   case TYPE_RATIONAL:
  352.     ARG_0(stackbase) = (a->RATIO).numerator;
  353.     return Fn_zerop(stackbase);
  354.   case TYPE_FLOAT:
  355.     return ((a->FLOAT).fvalue == (double)0.0E0 ? lisptrue : nil);
  356.   case TYPE_COMPLEX:
  357.     ARG_0(stacktop) = (a->COMPLEX).real;
  358.     if (Fn_zerop(stacktop)==nil) return nil;
  359.     ARG_0(stackbase) = (a->COMPLEX).imaginary;
  360.     return Fn_zerop(stackbase);
  361.   default:
  362.     CallError(stacktop,"Unimplemented facility in zerop",a,NONCONTINUABLE);
  363.   }
  364.   return nil;
  365. }
  366. EUFUN_CLOSE
  367.  
  368. EUFUN_1( Md_zerop_Number, a)
  369. {
  370.   return Fn_zerop(stackbase);
  371. }
  372. EUFUN_CLOSE
  373.  
  374. LispObject generic_abs;
  375.  
  376. EUFUN_1( Gf_abs, i)
  377. {
  378.   return(generic_apply_1(stackbase, generic_abs, i));
  379. }
  380. EUFUN_CLOSE
  381.  
  382. EUFUN_1( Fn_abs,  a)
  383. {
  384.   switch (typeof(a)) {
  385.   case TYPE_INT:
  386.     return (intval(a) < 0 ?
  387.          allocate_integer(stackbase, -intval(a)) : a);
  388.   case TYPE_BIGNUM:
  389.     return nil;
  390.   case TYPE_RATIONAL:
  391.     ARG_0(stacktop) = (a->RATIO).numerator;
  392.     return allocate_ratio(stackbase, Fn_abs(stacktop),(a->RATIO).denominator);
  393.   case TYPE_FLOAT:
  394.     return ((a->FLOAT).fvalue >= (double)0.0E0 ? a :
  395.         allocate_float(stackbase,-(a->FLOAT).fvalue));
  396.   case TYPE_COMPLEX:
  397.     {
  398.       LispObject r = (a->COMPLEX).real;
  399.       LispObject i = (a->COMPLEX).imaginary;
  400.       ARG_0(stacktop) = r;
  401.       ARG_1(stacktop) = r;
  402.       ARG_0(stackbase) = Fn_times(stacktop);
  403.       ARG_0(stacktop) = i;
  404.       ARG_1(stacktop) = i;
  405.       ARG_1(stackbase) = Fn_times(stacktop);
  406.       ARG_0(stackbase) = Fn_plus(stackbase);
  407.       a = lift_number(stackbase, TYPE_FLOAT);
  408.       return allocate_float(stackbase,sqrt((a->FLOAT).fvalue));
  409.     }
  410.   default:
  411.     CallError(stacktop,"Unimplemented facility in abs",a,NONCONTINUABLE);
  412.   }
  413.   return nil;
  414. }
  415. EUFUN_CLOSE
  416.  
  417. EUFUN_1( Md_abs_Number, a)
  418. {
  419.   return Fn_abs(stackbase);
  420. }
  421. EUFUN_CLOSE
  422.  
  423. /* *************************************************************** */
  424. /* Integer Arithmetic                                              */
  425. /* *************************************************************** */
  426.  
  427. EUFUN_1( Fn_fixnump, form)
  428. {
  429.   return (is_fixnum(form) ? lisptrue : nil);
  430. }
  431. EUFUN_CLOSE
  432.  
  433. EUFUN_1( Fn_oddp, form)
  434. {
  435.   while (!is_fixnum(form))
  436.     form = CallError(stacktop,"Not an integer in oddp ",form,CONTINUABLE);
  437.   return (((intval(form)) & 1)==0 ? nil : lisptrue);
  438. }
  439. EUFUN_CLOSE
  440.  
  441. EUFUN_1( Fn_evenp, form)
  442. {
  443.   while (!is_fixnum(form))
  444.     form = CallError(stacktop,"Not an integer in evenp ",form,CONTINUABLE);
  445.   return ((intval(form)) & 1 != 0 ? nil : lisptrue);
  446. }
  447. EUFUN_CLOSE
  448.  
  449. /* *************************************************************** */
  450. /* Floating Point Arithmetic                                       */
  451. /* *************************************************************** */
  452.  
  453. EUFUN_1( Fn_floatp, form)
  454. {
  455.   return (is_float(form) ? lisptrue : nil);
  456. }
  457. EUFUN_CLOSE
  458.  
  459. EUFUN_1( Fn_floor, form)
  460. {
  461.   double n;
  462.  
  463.   while (!is_number(form))
  464.     form = CallError(stacktop,"Not a number in floor ",form,CONTINUABLE);
  465.   form = lift_number(stackbase, TYPE_FLOAT);
  466.   n = floor((form->FLOAT).fvalue);
  467.   if (- (double)16777216.0 < n && n < (double)16777216.0)
  468.     return allocate_integer(stackbase, (int)n);
  469.   fprintf(stderr,"Floor to a bignum missing\n");
  470.   return nil;
  471. }
  472. EUFUN_CLOSE
  473.  
  474. EUFUN_1( Fn_ceiling, form)
  475. {
  476.   double n;
  477.  
  478.   while (!is_number(form))
  479.     form = CallError(stacktop,"Not a number in ceiling ",form,CONTINUABLE);
  480.   form = lift_number(stackbase, TYPE_FLOAT);
  481.   n = ceil((form->FLOAT).fvalue);
  482.   if (- (double)16777216.0 < n && n < (double)16777216.0)
  483.     return allocate_integer(stackbase, (int)n);
  484.   fprintf(stderr,"Ceiling to a bignum missing\n");
  485.   return nil;
  486. }
  487. EUFUN_CLOSE
  488.  
  489. EUFUN_1( Fn_truncate, f)
  490. {
  491.   if (is_fixnum(f)) return(f);
  492.   if (is_float(f)) {
  493.     long down;
  494.  
  495.     down = (long) floor(f->FLOAT.fvalue);
  496.     if ((double) abs((int) down) > f->FLOAT.fvalue) down += 1;
  497.     return (LispObject) allocate_integer(stackbase, (int) down);
  498.   }
  499.   CallError(stacktop,"truncate: no way",f,NONCONTINUABLE);
  500.  
  501.   return(nil);
  502. }
  503. EUFUN_CLOSE
  504.  
  505. EUFUN_1( Fn_round, f)
  506. {
  507.   if (is_fixnum(f)) return(f);
  508.   if (is_float(f)) {
  509.     long down;
  510.  
  511.     down = (long) floor(f->FLOAT.fvalue + (double) 0.5);
  512.     return (LispObject) allocate_integer(stackbase, (int) down);
  513.   }
  514.   CallError(stacktop,"round: no way",f,NONCONTINUABLE);
  515.  
  516.   return(nil);
  517. }
  518. EUFUN_CLOSE  
  519.     
  520. /* *************************************************************** */
  521. /* Floating Point Arithmetic                                       */
  522. /* *************************************************************** */
  523.  
  524. EUFUN_1( Fn_cos, form)
  525. {
  526.   while (!is_number(form))
  527.     form = CallError(stacktop,"Not a number in cos ",form,CONTINUABLE);
  528.   form = lift_number(stackbase, TYPE_FLOAT);
  529.   return allocate_float(stackbase,cos((form->FLOAT).fvalue));
  530. }
  531. EUFUN_CLOSE 
  532.  
  533. EUFUN_1( Fn_sin, form)
  534. {
  535.   while (!is_number(form))
  536.     form = CallError(stacktop,"Not a number in sin ",form,CONTINUABLE);
  537.   form = lift_number(stackbase, TYPE_FLOAT);
  538.   return allocate_float(stackbase,sin((form->FLOAT).fvalue));
  539. }
  540. EUFUN_CLOSE
  541.  
  542. EUFUN_1( Fn_sqrt, form)
  543. {
  544.   while (!is_number(form))
  545.     form = CallError(stacktop,"Not a number in sin ",form,CONTINUABLE);
  546.   form = lift_number(stackbase, TYPE_FLOAT);
  547.   return allocate_float(stackbase,sqrt((form->FLOAT).fvalue));
  548. }
  549. EUFUN_CLOSE
  550.   
  551. EUFUN_1( Fn_exp, form)
  552. {
  553.   while (!is_number(form))
  554.     form = CallError(stacktop,"Not a number in exp ",form,CONTINUABLE);
  555.   form = lift_number(stackbase, TYPE_FLOAT);
  556.   return allocate_float(stackbase,exp((form->FLOAT).fvalue));
  557. }
  558. EUFUN_CLOSE
  559.  
  560.                 /* This function does not check correctly */
  561. EUFUN_1( Fn_log, form)
  562. {
  563.   LispObject base, arg1;
  564.   while (!is_cons(form))
  565.     form = CallError(stacktop,"No argument(s) to log ",form,CONTINUABLE);
  566.   arg1 = CAR(form);
  567.   while (!is_number(arg1))
  568.     ARG_0(stacktop) = CallError(stacktop,"Not a number in log ",arg1,CONTINUABLE);
  569.   arg1 = lift_number(stacktop, TYPE_FLOAT);
  570.   if (is_cons(CDR(form))) {
  571.     base = CAR(CDR(form));
  572.     while (!is_number(base))
  573.       base = CallError(stacktop,"Not a base in log ",base,CONTINUABLE);
  574.     ARG_0(stacktop) = arg1;
  575.     ARG_1(stacktop) = arg1;
  576.     base = lift_number(stacktop+1, TYPE_FLOAT);
  577.     return
  578.       allocate_float(stackbase,
  579.              log((arg1->FLOAT).fvalue) / log((base->FLOAT).fvalue));
  580.   }
  581.   else
  582.     return allocate_float(stackbase,log((arg1->FLOAT).fvalue));
  583. }
  584. EUFUN_CLOSE
  585.  
  586. EUFUN_1( Fn_acos, form)
  587. {
  588.   while (!is_number(form))
  589.     form = CallError(stacktop,"Not a number in acos ",form,CONTINUABLE);
  590.   form = lift_number(stackbase, TYPE_FLOAT);
  591.   return allocate_float(stackbase,acos((form->FLOAT).fvalue));
  592. }
  593. EUFUN_CLOSE
  594.  
  595. EUFUN_1( Fn_asin, form)
  596. {
  597.   while (!is_number(form))
  598.     form = CallError(stacktop,"Not a number in asin ",form,CONTINUABLE);
  599.   form = lift_number(stackbase, TYPE_FLOAT);
  600.   return allocate_float(stacktop,asin((form->FLOAT).fvalue));
  601. }
  602. EUFUN_CLOSE
  603.  
  604. EUFUN_1( Fn_atan, form)
  605. {
  606.   while (!is_number(form))
  607.     form = CallError(stacktop,"Not a number in atan ",form,CONTINUABLE);
  608.   form = lift_number(stackbase, TYPE_FLOAT);
  609.   return allocate_float(stacktop,atan((form->FLOAT).fvalue));
  610. }
  611. EUFUN_CLOSE
  612.  
  613. EUFUN_2( Fn_atan2, form1, form2)
  614. {
  615.   while (!is_number(form1))
  616.     form1 = CallError(stacktop,"Not a number in atan2 ",form1,CONTINUABLE);
  617.   ARG_0(stacktop) = form1;
  618.   ARG_0(stackbase) = lift_number(stacktop, TYPE_FLOAT);
  619.   while (!is_number(form2))
  620.     form2 = CallError(stacktop,"Not a number in atan2 ",form2,CONTINUABLE);
  621.   form2 = lift_number(stackbase+1, TYPE_FLOAT);
  622.   form1 = ARG_0(stackbase);
  623.   return allocate_float(stacktop,
  624.             atan2((form1->FLOAT).fvalue,(form2->FLOAT).fvalue));
  625. }
  626. EUFUN_CLOSE
  627.  
  628. EUFUN_1( Fn_tan, form)
  629. {
  630.   while (!is_number(form))
  631.     form = CallError(stacktop,"Not a number in tan ",form,CONTINUABLE);
  632.   form = lift_number(stackbase, TYPE_FLOAT);
  633.   return allocate_float(stacktop,tan((form->FLOAT).fvalue));
  634. }
  635. EUFUN_CLOSE
  636.  
  637. EUFUN_1( Fn_acosh, form)
  638. {
  639.   double x;
  640.   while (!is_number(form))
  641.     form = CallError(stacktop,"Not a number in acosh ",form,CONTINUABLE);
  642.   form = lift_number(stackbase, TYPE_FLOAT);
  643.   x = (form->FLOAT).fvalue;
  644.   return allocate_float(stackbase,log(x+sqrt(x*x-1)));
  645. }
  646. EUFUN_CLOSE
  647.  
  648. EUFUN_1( Fn_asinh, form)
  649. {
  650.   double x;
  651.   while (!is_number(form))
  652.     form = CallError(stacktop,"Not a number in asinh ",form,CONTINUABLE);
  653.   form = lift_number(stackbase, TYPE_FLOAT);
  654.   x = (form->FLOAT).fvalue;
  655.   return allocate_float(stackbase,log(x+sqrt(x*x+1)));
  656. }
  657. EUFUN_CLOSE
  658.  
  659. EUFUN_1( Fn_atanh, form)
  660. {
  661.   double x;
  662.   while (!is_number(form))
  663.     form = CallError(stacktop,"Not a number in atanh ",form,CONTINUABLE);
  664.   form = lift_number(stackbase, TYPE_FLOAT);
  665.   x = (form->FLOAT).fvalue;
  666.   return allocate_float(stackbase,0.5*(log((x+1.0)/(x-1.0))));
  667. }
  668. EUFUN_CLOSE
  669.  
  670. EUFUN_1( Fn_cosh, form)
  671. {
  672.   while (!is_number(form))
  673.     form = CallError(stacktop,"Not a number in cosh ",form,CONTINUABLE);
  674.   form = lift_number(stackbase, TYPE_FLOAT);
  675.   return allocate_float(stackbase,cosh((form->FLOAT).fvalue));
  676. }
  677. EUFUN_CLOSE
  678.  
  679. EUFUN_1( Fn_sinh, form)
  680. {
  681.   while (!is_number(form))
  682.     form = CallError(stacktop,"Not a number in sinh ",form,CONTINUABLE);
  683.   form = lift_number(stackbase, TYPE_FLOAT);
  684.   return allocate_float(stackbase,sinh((form->FLOAT).fvalue));
  685. }
  686. EUFUN_CLOSE
  687.  
  688. EUFUN_1( Fn_tanh, form)
  689. {
  690.   while (!is_number(form))
  691.     form = CallError(stacktop,"Not a number in tanh ",form,CONTINUABLE);
  692.   form = lift_number(stackbase, TYPE_FLOAT);
  693.   return allocate_float(stackbase,tanh((form->FLOAT).fvalue));
  694. }
  695. EUFUN_CLOSE
  696.  
  697. /* Generic versions... */
  698.  
  699. LispObject generic_eqn;
  700.  
  701. EUFUN_2(Gf_eqn, i1, i2)
  702. {
  703.   return(generic_apply_2(stackbase, generic_eqn, i1, i2));
  704. }
  705. EUFUN_CLOSE
  706.  
  707. EUFUN_2(Md_eqn_Number_Number, i1, i2)
  708. {
  709.   return(Fn_eqn(stackbase));
  710. }
  711. EUFUN_CLOSE
  712.  
  713. LispObject generic_binary_plus;
  714.  
  715. EUFUN_2(Gf_binary_plus, a, b)
  716. {
  717.   return(generic_apply_2(stackbase, generic_binary_plus, a, b));
  718. }
  719. EUFUN_CLOSE
  720.  
  721. EUFUN_2(Md_binary_plus_Object_Object, n1, n2)
  722. {
  723.   return(Fn_plus(stackbase));
  724. }
  725. EUFUN_CLOSE
  726.  
  727. EUFUN_2( Md_binary_plus_Integer_Integer, i1, i2)
  728. {
  729.   return((LispObject)allocate_integer(stackbase, intval(i1)+intval(i2)));
  730. }
  731. EUFUN_CLOSE
  732.  
  733. LispObject generic_binary_difference;
  734.  
  735. EUFUN_2( Gf_binary_difference, a, b)
  736. {
  737.   return(generic_apply_2(stackbase, generic_binary_difference,a, b));
  738. }
  739. EUFUN_CLOSE
  740.  
  741. EUFUN_2( Md_binary_difference_Object_Object, n1, n2)
  742. {
  743.   return(Fn_difference(stackbase));
  744. }
  745. EUFUN_CLOSE
  746.  
  747. EUFUN_2( Md_binary_difference_Integer_Integer, i1, i2)
  748. {
  749.   return((LispObject)allocate_integer(stackbase, intval(i1)-intval(i2)));
  750. }
  751. EUFUN_CLOSE
  752.  
  753. LispObject generic_binary_times;
  754.  
  755. EUFUN_2( Gf_binary_times, a, b)
  756. {
  757.   return(generic_apply_2(stackbase, generic_binary_times, a, b));
  758. }
  759. EUFUN_CLOSE
  760.  
  761. EUFUN_2( Md_binary_times_Object_Object, n1, n2)
  762. {
  763.   return(Fn_times(stackbase));
  764. }
  765. EUFUN_CLOSE
  766.  
  767. EUFUN_2( Md_binary_times_Integer_Integer, i1, i2)
  768. {
  769.   return((LispObject)allocate_integer(stackbase, intval(i1)*intval(i2)));
  770. }
  771. EUFUN_CLOSE
  772.  
  773. LispObject generic_binary_divide;
  774.  
  775. EUFUN_2( Gf_binary_divide, a, b)
  776. {
  777.   return(generic_apply_2(stackbase, generic_binary_divide, a, b));
  778. }
  779. EUFUN_CLOSE
  780.  
  781. EUFUN_2( Md_binary_divide_Object_Object, n1, n2)
  782. {
  783.   return(Fn_divide(stackbase));
  784. }
  785. EUFUN_CLOSE
  786.  
  787. EUFUN_2( Md_binary_divide_Integer_Integer, i1, i2)
  788. {
  789.   return((LispObject) allocate_integer(stacktop, intval(i1)/intval(i2)));
  790. }
  791. EUFUN_CLOSE
  792.  
  793. /* Wrappers... */
  794.  
  795. EUFUN_1( Fn_nary_plus, args)
  796. {
  797.   LispObject walker;
  798.   LispObject n1,n2;
  799.  
  800.   walker = args;
  801.  
  802.   if (!is_cons(walker))
  803.     CallError(stacktop,"+: no arguments",args,NONCONTINUABLE);
  804.  
  805.   n1 = CAR(walker); walker = CDR(walker);
  806.  
  807.   if (!is_cons(walker))
  808.     CallError(stacktop,"+: insufficient arguments",args,NONCONTINUABLE);
  809.  
  810.   n2 = CAR(walker); walker = CDR(walker);
  811.   n1 = generic_apply_2(stacktop, generic_binary_plus, n1, n2);
  812.  
  813.   while (is_cons(walker)) {
  814.     STACK_TMP(CDR(walker));
  815.     n1 = generic_apply_2(stacktop, generic_binary_plus, n1, CAR(walker));
  816.     UNSTACK_TMP(walker);
  817.   }
  818.  
  819.   return(n1);
  820. }
  821. EUFUN_CLOSE
  822.  
  823. EUFUN_1( Fn_nary_difference, args)
  824. {
  825.   LispObject walker;
  826.   LispObject n1,n2;
  827.  
  828.   walker = args;
  829.  
  830.   if (!is_cons(walker))
  831.     CallError(stacktop,"-: no arguments",args,NONCONTINUABLE);
  832.  
  833.   n1 = CAR(walker); walker = CDR(walker);
  834.  
  835.   if (!is_cons(walker)) {
  836.     LispObject xx;
  837.     STACK_TMP(n1);
  838.     xx = allocate_integer(stacktop, 0);
  839.     UNSTACK_TMP(n1);
  840.     return(generic_apply_2(stackbase, generic_binary_difference,xx, n1));
  841.   }
  842.  
  843.   n2 = CAR(walker); STACK_TMP(CDR(walker));
  844.   n1 = generic_apply_2(stacktop, generic_binary_difference,n1, n2);
  845.   UNSTACK_TMP(walker);
  846.  
  847.   while (is_cons(walker)) {
  848.     STACK_TMP(CDR(walker));
  849.     n1 = generic_apply_2(stacktop, generic_binary_difference,n1, CAR(walker));
  850.     UNSTACK_TMP(walker);
  851.   }
  852.  
  853.   return(n1);
  854. }
  855. EUFUN_CLOSE
  856.  
  857. EUFUN_1( Fn_nary_times, args)
  858. {
  859.   LispObject walker;
  860.   LispObject n1,n2;
  861.  
  862.   walker = args;
  863.  
  864.   if (!is_cons(walker))
  865.     CallError(stacktop,"*: no arguments",args,NONCONTINUABLE);
  866.  
  867.   n1 = CAR(walker); walker = CDR(walker);
  868.  
  869.   if (!is_cons(walker))
  870.     CallError(stacktop,"*: insufficient arguments",args,NONCONTINUABLE);
  871.  
  872.   STACK_TMP(CDR(walker));
  873.   n1 = generic_apply_2(stacktop, generic_binary_times, n1, CAR(walker));
  874.   UNSTACK_TMP(walker);
  875.  
  876.   while (is_cons(walker)) {
  877.     STACK_TMP(CDR(walker));
  878.     n1 = generic_apply_2(stacktop, generic_binary_times,n1, CAR(walker));
  879.     UNSTACK_TMP(walker);
  880.   }
  881.  
  882.   return(n1);
  883. }
  884. EUFUN_CLOSE
  885.  
  886. EUFUN_1( Fn_nary_divide, args)
  887. {
  888.   LispObject walker;
  889.   LispObject n1,n2;
  890.  
  891.   walker = args;
  892.  
  893.   if (!is_cons(walker))
  894.     CallError(stacktop,"/: no arguments",args,NONCONTINUABLE);
  895.  
  896.   n1 = CAR(walker); walker = CDR(walker);
  897.  
  898.   if (!is_cons(walker))
  899.     CallError(stacktop,"/: insufficient arguments",args,NONCONTINUABLE);
  900.  
  901.   STACK_TMP(CDR(walker));
  902.   n1 = generic_apply_2(stacktop, generic_binary_divide, n1, CAR(walker));
  903.   UNSTACK_TMP(walker);
  904.  
  905.   while (is_cons(walker)) {
  906.     STACK_TMP(CDR(walker));
  907.     n1 = generic_apply_2(stacktop, generic_binary_divide,n1, CAR(walker));
  908.     UNSTACK_TMP(walker);
  909.   }
  910.  
  911.   return(n1);
  912. }
  913. EUFUN_CLOSE
  914.  
  915. /*
  916.  * Integer operations...
  917.  */
  918.  
  919. EUFUN_2(Fn_quotient, n, m)
  920. {
  921.   if (!is_fixnum(n))
  922.     CallError(stacktop,"quotient: not an integer",n,NONCONTINUABLE);
  923.  
  924.   if (!is_fixnum(m))
  925.     CallError(stacktop,"quotient: not an integer",m,NONCONTINUABLE);
  926.  
  927.   return((LispObject) allocate_integer(stackbase, intval(n)/intval(m)));
  928. }
  929. EUFUN_CLOSE
  930.  
  931. EUFUN_2(Fn_remainder, n, m)
  932. {
  933.  
  934.   if (!is_fixnum(n))
  935.     CallError(stacktop,"remainder(hack): non-integer as argument",n,NONCONTINUABLE);
  936.  
  937.   if (!is_fixnum(m))
  938.     CallError(stacktop,"remainder(hack): non-integer as argument",m,NONCONTINUABLE);
  939.  
  940.   return((LispObject) allocate_integer(stackbase, intval(n)%intval(m)));
  941.  
  942. }
  943. EUFUN_CLOSE
  944.  
  945. /*
  946.  * GCD calculation.
  947.  */
  948.  
  949. LispObject generic_binary_gcd;
  950.  
  951. EUFUN_2(Gf_binary_gcd, n1, n2)
  952. {
  953.   return(generic_apply_2(stackbase, generic_binary_gcd,n1, n2));
  954. }
  955. EUFUN_CLOSE
  956.  
  957. EUFUN_2( Md_binary_gcd_Integer_Integer, n1, n2)
  958. {
  959.   extern int abs(int);
  960.   int a,b,r;
  961.   LispObject ans;
  962.  
  963.   a = abs(intval(n1)); b = abs(intval(n2));
  964.  
  965.   do {
  966.     
  967.     r = a%b;
  968.     a = b; b = r;
  969.  
  970.   } while(b != 0);
  971.  
  972.   return (LispObject) allocate_integer(stackbase, a);
  973.  
  974.   return(ans);
  975. }
  976. EUFUN_CLOSE
  977.  
  978. EUFUN_1( Fn_gcd, args)
  979. {
  980.   LispObject v1,v2;
  981.  
  982.   if (intval(Fn_length(stackbase)) < 2)
  983.     CallError(stacktop,"gcd: insufficient arguments",args,NONCONTINUABLE);
  984.   
  985.   v1 = CAR(args); args = CDR(args);
  986.  
  987.   while (is_cons(args)) {
  988.  
  989.     ARG_0(stacktop) = v1;
  990.     ARG_1(stacktop)= v2 = CAR(args); ARG_0(stackbase) = CDR(args);
  991.     v1 = Gf_binary_gcd(stacktop);
  992.     args = ARG_0(stackbase);
  993.     
  994.   }
  995.  
  996.   return(v1);
  997. }
  998. EUFUN_CLOSE
  999.  
  1000. /*
  1001.  * LCM calculation.
  1002.  */
  1003.  
  1004. LispObject generic_binary_lcm;
  1005.  
  1006. EUFUN_2(Gf_binary_lcm, n1, n2)
  1007. {
  1008.   return(generic_apply_2(stackbase, generic_binary_lcm, n1, n2));
  1009. }
  1010. EUFUN_CLOSE
  1011.  
  1012. EUFUN_2( Md_binary_lcm_Integer_Integer, n1, n2)
  1013. {
  1014.   extern int abs(int);
  1015.   int a,b,r,origa,origb;
  1016.  
  1017.   a = abs(intval(n1)); b = abs(intval(n2));
  1018.   origa = a; origb = b;
  1019.   do {
  1020.     r = a%b;
  1021.     a = b; b = r;
  1022.   } while(b != 0);
  1023.  
  1024.   a = (origa/a)*origb;
  1025.   return (LispObject) allocate_integer(stackbase, a);
  1026. }
  1027. EUFUN_CLOSE
  1028.  
  1029. EUFUN_1( Fn_lcm, args)
  1030. {
  1031.   LispObject v1,v2;
  1032.   
  1033.   if (intval(Fn_length(stackbase)) < 2)
  1034.     CallError(stacktop,"lcm: insufficient arguments",args,NONCONTINUABLE);
  1035.   v1 = CAR(args); args = CDR(args);
  1036.   while (is_cons(args)) {
  1037.     ARG_0(stacktop) = v1;
  1038.     ARG_1(stacktop) = v2 = CAR(args); ARG_0(stackbase) = CDR(args);
  1039.     v1 = Gf_binary_lcm(stacktop);
  1040.     args = ARG_0(stackbase);
  1041.   }
  1042.  
  1043.   return(v1);
  1044. }
  1045. EUFUN_CLOSE
  1046.  
  1047. /* *************************************************************** */
  1048. /*                           Ordering                              */
  1049. /* *************************************************************** */  
  1050.  
  1051. LispObject generic_binary_lt;
  1052.  
  1053. EUFUN_2(Gf_binary_lt, a, b)
  1054. {
  1055.   return(generic_apply_2(stackbase, generic_binary_lt, a, b));
  1056. }
  1057. EUFUN_CLOSE
  1058.  
  1059. EUFUN_2(Md_binary_lt_Number, a, b)
  1060. {
  1061.   return(Fn_lessp(stackbase));
  1062. }
  1063. EUFUN_CLOSE
  1064.  
  1065. EUFUN_2(Md_binary_lt_Integer, a, b)
  1066. {
  1067.   return(intval(a)<intval(b) ? lisptrue : nil);
  1068. }
  1069. EUFUN_CLOSE
  1070.  
  1071.  
  1072. EUFUN_1( Fn_lt, args)
  1073. {
  1074.   LispObject a;
  1075.  
  1076.   if (!is_cons(args))
  1077.     CallError(stacktop,"<: insufficient arguments",args,NONCONTINUABLE);
  1078.  
  1079.   a = CAR(args); args = CDR(args);
  1080.   
  1081.   if (!is_cons(args)) return(lisptrue);
  1082.  
  1083.   while (is_cons(args)) {
  1084.     ARG_0(stacktop) = a;
  1085.     ARG_1(stacktop) = CAR(args);
  1086.     if (Gf_binary_lt(stacktop) == nil) return(nil);
  1087.     a = CAR(args);
  1088.     args = CDR(args);
  1089.     ARG_0(stackbase) = args;
  1090.   }
  1091.  
  1092.   return(lisptrue);
  1093. }
  1094. EUFUN_CLOSE
  1095.  
  1096.  
  1097. LispObject generic_binary_gt;
  1098.  
  1099. EUFUN_2(Gf_binary_gt, a, b)
  1100. {
  1101.   return(generic_apply_2(stackbase, generic_binary_gt,a, b));
  1102. }
  1103. EUFUN_CLOSE
  1104.  
  1105. EUFUN_2(Md_binary_gt_Number, a, b)
  1106. {
  1107.   ARG_0(stackbase) = b;
  1108.   ARG_1(stackbase) = a;
  1109.   return(Gf_binary_lt(stackbase));
  1110. }
  1111. EUFUN_CLOSE
  1112.  
  1113. EUFUN_2(Md_binary_gt_Integer, a, b)
  1114. {
  1115.   return(intval(a)>intval(b) ? lisptrue : nil);
  1116. }
  1117. EUFUN_CLOSE
  1118.  
  1119. EUFUN_1( Fn_gt, args)
  1120. {
  1121.   LispObject a;
  1122.  
  1123.   if (!is_cons(args))
  1124.     CallError(stacktop,">: insufficient arguments",args,NONCONTINUABLE);
  1125.  
  1126.   a = CAR(args); args = CDR(args);
  1127.   
  1128.   if (!is_cons(args)) return(lisptrue);
  1129.  
  1130.   while (is_cons(args)) {
  1131.     ARG_0(stacktop) = a;
  1132.     ARG_1(stacktop) = CAR(args);
  1133.     if (Gf_binary_gt(stacktop) == nil) return(nil);
  1134.     a = CAR(args);
  1135.     args = CDR(args);
  1136.     ARG_0(stackbase) = args;
  1137.   }
  1138. #ifdef jpff_version /* Fri Sep  6 17:51:33 1991 */
  1139. /**/  while (is_cons(args)) {
  1140. /**/    ARG_0(stacktop) = a;
  1141. /**/    ARG_1(stacktop) = CAR(args); 
  1142. /**/    ARG_0(stackbase) = CDR(args);
  1143. /**/    if (Gf_binary_gt(stacktop) == nil) return(nil);
  1144. /**/    a = ARG_1(stacktop);
  1145. /**/    args = ARG_0(stackbase);
  1146. /**/  }
  1147. #endif /* jpff's version Fri Sep  6 17:51:33 1991 */
  1148.  
  1149.   return(lisptrue);
  1150. }
  1151. EUFUN_CLOSE
  1152.  
  1153. EUFUN_1( Fn_lt_or_equal, args)
  1154. {
  1155.   LispObject a;
  1156.  
  1157.   if (!is_cons(args))
  1158.     CallError(stacktop,"<=: insufficient arguments",args,NONCONTINUABLE);
  1159.  
  1160.   a = CAR(args); args = CDR(args);
  1161.  
  1162.   STACK_TMP(args);
  1163.   if (!is_cons(args)) return(lisptrue);
  1164.  
  1165.   while (is_cons(args)) {
  1166.     ARG_0(stacktop) = a;
  1167.     ARG_1(stacktop) = CAR(args);
  1168.     if (Gf_binary_lt(stacktop) == nil && EUCALL_2(Gf_eqn,a,CAR(args)) == nil)
  1169.       return nil;
  1170.     a = CAR(args);
  1171.  
  1172.     args = CDR(args);
  1173.     ARG_0(stackbase) = args;
  1174.   }
  1175.  
  1176.   return(lisptrue);
  1177. }
  1178. EUFUN_CLOSE
  1179.  
  1180. EUFUN_1( Fn_gt_or_equal, args)
  1181. {
  1182.   LispObject a;
  1183.  
  1184.   if (!is_cons(args))
  1185.     CallError(stacktop,">=: insufficient arguments",args,NONCONTINUABLE);
  1186.  
  1187.   a = CAR(args); args = CDR(args);
  1188.   ARG_0(stackbase)=args;
  1189.   if (!is_cons(args)) return(lisptrue);
  1190.  
  1191.   while (is_cons(args)) {
  1192.     ARG_0(stacktop) = a;
  1193.     ARG_1(stacktop) = CAR(args);
  1194.     if (Gf_binary_gt(stacktop) == nil && EUCALL_2(Gf_eqn,a,CAR(args)) == nil)
  1195.       return nil;
  1196.     a = CAR(args);
  1197.     args = CDR(args);
  1198.     ARG_0(stackbase) = args;
  1199.   }
  1200.  
  1201.   return(lisptrue);
  1202. }
  1203. EUFUN_CLOSE
  1204.  
  1205. LispObject generic_max;
  1206.  
  1207. EUFUN_2(Gf_max, a, b)
  1208. {
  1209.   return(generic_apply_2(stackbase, generic_max, a, b));
  1210. }
  1211. EUFUN_CLOSE
  1212.  
  1213. EUFUN_2(Md_max_Number_Number, a, b)
  1214. {
  1215.   if (EUCALL_2(Gf_binary_lt, a,b) != nil) return(ARG_1(stackbase));
  1216.   return(ARG_0(stackbase));
  1217. }
  1218. EUFUN_CLOSE
  1219.  
  1220. EUFUN_1( Fn_min, a)
  1221. {
  1222.   LispObject ans,xxx;
  1223.   while (!is_cons(a))
  1224.     a = CallError(stacktop,"Too few arguments for min ",a,CONTINUABLE);
  1225.   ans = CAR(a);
  1226.   a = CDR(a);
  1227.   while (!is_number(ans))
  1228.     ans = CallError(stacktop,"Non numeric argument for min ",ans,CONTINUABLE);
  1229.   while (a != nil) {
  1230.     LispObject b = CAR(a);
  1231.     while (!is_number(b)) 
  1232.       b = CallError(stacktop,"Non numeric argument for min ",b,CONTINUABLE);
  1233.     ARG_0(stackbase) = a;
  1234.     STACK_TMP(ans);
  1235.     STACK_TMP(b);
  1236.     ARG_0(stacktop) = ans;
  1237.     ARG_1(stacktop) = b;
  1238.     xxx = Md_max_Number_Number(stacktop);
  1239.     UNSTACK_TMP(b);
  1240.     UNSTACK_TMP(ans);
  1241.     if (xxx == ans)
  1242.       ans = b;
  1243.     else /*ans = ans */;
  1244.     a = CDR(ARG_0(stackbase));
  1245.   }
  1246.   return(ans);
  1247. }
  1248. EUFUN_CLOSE
  1249.  
  1250. EUFUN_1( Fn_max, a)
  1251. {
  1252.   LispObject ans,xxx;
  1253.   while (!is_cons(a))
  1254.     a = CallError(stacktop,"Too few arguments for max ",a,CONTINUABLE);
  1255.   ans = CAR(a);
  1256.   a = CDR(a);
  1257.   while (!is_number(ans))
  1258.     ans = CallError(stacktop,"Non numeric argument for max ",ans,CONTINUABLE);
  1259.   while (a != nil) {
  1260.     LispObject b = CAR(a);
  1261.     while (!is_number(b)) 
  1262.       b = CallError(stacktop,"Non numeric argument for max ",b,CONTINUABLE);
  1263.     ARG_0(stackbase) = a;
  1264.     STACK_TMP(ans);
  1265.     STACK_TMP(b);
  1266.     ARG_0(stacktop) = ans;
  1267.     ARG_1(stacktop) = b;
  1268.     xxx = Md_max_Number_Number(stacktop);
  1269.     UNSTACK_TMP(b); 
  1270.     UNSTACK_TMP(ans);
  1271.     if (xxx == b)
  1272.       ans = b;
  1273.     else /* ans = ans */;
  1274.     a = CDR(ARG_0(stackbase));
  1275.   }
  1276.   return(ans);
  1277. }
  1278. EUFUN_CLOSE
  1279.  
  1280. /* *************************************************************** */
  1281. /* COMPLEX NUMBERS                                                 */
  1282. /* *************************************************************** */
  1283.  
  1284. EUFUN_2( Fn_Make_Rectangular, x, y)
  1285. {
  1286.   while (!is_number(x) || (typeof(x)== TYPE_COMPLEX))
  1287.     x = CallError(stacktop,"make-rectangular: first argument not valid number",
  1288.           x,CONTINUABLE);
  1289.   while (!is_number(y) || (typeof(y)==TYPE_COMPLEX))
  1290.     y = CallError(stacktop,"make-rectangular: second argument not valid number",
  1291.           y,CONTINUABLE);
  1292.   return allocate_complex(stackbase,x,y);
  1293. }
  1294. EUFUN_CLOSE
  1295.  
  1296. EUFUN_1( Fn_Real_Part, obj)
  1297. {
  1298.   while (!is_number(obj))
  1299.     obj = CallError(stacktop,"Not a number in real-part",obj,CONTINUABLE);
  1300.   if (typeof(obj)==TYPE_COMPLEX)
  1301.     return obj->COMPLEX.real;
  1302.   else return obj;
  1303. }
  1304. EUFUN_CLOSE
  1305.  
  1306. EUFUN_1( Fn_Imaginary_Part, obj)
  1307. {
  1308.   while (!is_number(obj))
  1309.     obj = CallError(stacktop,"Not a number in imaginary-part",obj,CONTINUABLE);
  1310.   if (typeof(obj)==TYPE_COMPLEX)
  1311.     return obj->COMPLEX.imaginary;
  1312.   else return allocate_float(stackbase,(double)0.0);
  1313. }
  1314. EUFUN_CLOSE
  1315.  
  1316. /* *************************************************************** */
  1317. /* RATIONAL NUMBERS                                                */
  1318. /* *************************************************************** */
  1319.  
  1320. EUFUN_1( Fn_Numerator, obj)
  1321. {
  1322.   while (!is_number(obj))
  1323.     obj = CallError(stacktop,"Not a number in numerator",obj,CONTINUABLE);
  1324.   if (typeof(obj)==TYPE_RATIONAL)
  1325.     return obj->RATIO.numerator;
  1326.   else return obj;
  1327. }
  1328. EUFUN_CLOSE
  1329.  
  1330. EUFUN_1( Fn_Denominator, obj)
  1331. {
  1332.   while (!is_number(obj))
  1333.     obj = CallError(stacktop,"Not a number in denominator",obj,CONTINUABLE);
  1334.   if (typeof(obj)==TYPE_RATIONAL)
  1335.     return obj->RATIO.denominator;
  1336.   else return allocate_integer(stackbase, 1);
  1337. }
  1338. EUFUN_CLOSE
  1339.  
  1340.  
  1341.  
  1342. /* *************************************************************** */
  1343. /* Initialisation of this section                                  */
  1344. /* *************************************************************** */
  1345.  
  1346. #define ARITH_ENTRIES 75
  1347. MODULE Module_arith;
  1348. LispObject Module_arith_values[ARITH_ENTRIES];
  1349.  
  1350. void initialise_arith(LispObject *stacktop)
  1351. {
  1352.   extern LispObject generic_equal;
  1353.  
  1354.   open_module(stacktop,
  1355.           &Module_arith,
  1356.           Module_arith_values,
  1357.           "arith",
  1358.           ARITH_ENTRIES);
  1359.  
  1360.   (void) make_module_function(stacktop,"numberp",Fn_numberp,1);
  1361.  
  1362.   generic_binary_plus 
  1363.     = make_wrapped_module_generic(stacktop,"binary-plus",2,Gf_binary_plus);
  1364.   add_root(&generic_binary_plus);
  1365.   (void) make_module_function(stacktop,"generic_binary_plus,Number,Number",
  1366.                   Md_binary_plus_Object_Object,2
  1367.                   );
  1368.  
  1369. #ifndef WITH_BIGNUMS
  1370.   (void) make_module_function(stacktop,"generic_binary_plus,Integer,Integer",
  1371.                   Md_binary_plus_Integer_Integer,2
  1372.                   );
  1373. #endif
  1374.  
  1375.   (void) make_module_function(stacktop,"+",Fn_nary_plus,-1);
  1376.  
  1377.   generic_binary_difference 
  1378.     = make_wrapped_module_generic(stacktop,"binary-difference",2,Gf_binary_difference);
  1379.   add_root(&generic_binary_difference);
  1380.   (void) make_module_function(stacktop,"generic_binary_difference,Number,Number",
  1381.                   Md_binary_difference_Object_Object,2
  1382.                   );
  1383.  
  1384. #ifndef WITH_BIGNUMS
  1385.   (void) make_module_function(stacktop,"generic_binary_difference,Integer,Integer",
  1386.                   Md_binary_difference_Integer_Integer,2
  1387.                   );
  1388. #endif
  1389.  
  1390.   (void) make_module_function(stacktop,"-",Fn_nary_difference,-1);
  1391.  
  1392.   generic_binary_times 
  1393.     = make_wrapped_module_generic(stacktop,"binary-times",2,Gf_binary_times);
  1394.   add_root(&generic_binary_times);
  1395.   (void) make_module_function(stacktop,"generic_binary_times,Number,Number",
  1396.                   Md_binary_times_Object_Object,2
  1397.                   );
  1398.  
  1399. #ifndef WITH_BIGNUMS
  1400.   (void) make_module_function(stacktop,"generic_binary_times,Integer,Integer",
  1401.                   Md_binary_times_Integer_Integer,2
  1402.                   );
  1403. #endif
  1404.  
  1405.   (void) make_module_function(stacktop,"*",Fn_nary_times,-1);
  1406.  
  1407.   generic_binary_divide 
  1408.     = make_wrapped_module_generic(stacktop,"binary-divide",2,Gf_binary_divide);
  1409.   add_root(&generic_binary_divide);
  1410.   (void) make_module_function(stacktop,"generic_binary_divide,Number,Number",
  1411.                   Md_binary_divide_Object_Object,2
  1412.                   );
  1413. /*
  1414.   (void) make_module_function(stacktop,generic_binary_divide,
  1415.                   Md_binary_divide_Integer_Integer,
  1416.                   Integer,Integer);
  1417. */
  1418.   (void) make_module_function(stacktop,"/",Fn_nary_divide,-1);
  1419.  
  1420.   generic_binary_gcd 
  1421.     = make_wrapped_module_generic(stacktop,"binary-gcd",2,Gf_binary_gcd);
  1422.   add_root(&generic_binary_gcd);
  1423.   (void) make_module_function(stacktop,"generic_binary_gcd,Integer,Integer",
  1424.                   Md_binary_gcd_Integer_Integer,2
  1425.                   );
  1426.   (void) make_module_function(stacktop,"gcd",Fn_gcd,-1);
  1427.   generic_binary_lcm 
  1428.     = make_wrapped_module_generic(stacktop,"binary-lcm",2,Gf_binary_lcm);
  1429.   add_root(&generic_binary_lcm);
  1430.   (void) make_module_function(stacktop,"generic_binary_lcm,Integer,Integer",
  1431.                   Md_binary_lcm_Integer_Integer,2
  1432.                   );
  1433.   (void) make_module_function(stacktop,"lcm",Fn_lcm,-1);
  1434.  
  1435.   generic_eqn = make_wrapped_module_generic(stacktop,"=",2,Gf_eqn);
  1436.   add_root(&generic_eqn);
  1437.   (void) make_module_function(stacktop,"generic_eqn,Number,Number",
  1438.                   Md_eqn_Number_Number,2
  1439.                   );
  1440.   (void) make_module_function(stacktop,"generic_equal,Number,Number",
  1441.                   Gf_eqn,2
  1442.                   );
  1443.  
  1444.   generic_zerop = make_wrapped_module_generic(stacktop,"zerop",1,Gf_zerop);
  1445.   add_root(&generic_zerop);
  1446.   (void) make_module_function(stacktop,"generic_zerop,Number", Md_zerop_Number,1);
  1447.  
  1448.   generic_abs = make_wrapped_module_generic(stacktop,"abs",1,Gf_abs);
  1449.   add_root(&generic_abs);
  1450.   (void) make_module_function(stacktop,"generic_abs,Number",Md_abs_Number,1);
  1451.  
  1452.   /* Maths constants... */
  1453.  
  1454.   (void) make_module_entry(stacktop, "pi",allocate_float(stacktop,(double) 3.141592653589794));
  1455.   (void) make_module_entry(stacktop, "e",allocate_float(stacktop,(double) 2.718281828459046));
  1456.  
  1457.   (void) make_module_function(stacktop,"single-precision-integer-p",Fn_fixnump,1);
  1458.   (void) make_module_function(stacktop,"oddp",Fn_oddp,1);
  1459.   (void) make_module_function(stacktop,"evenp",Fn_evenp,1);
  1460.   (void) make_module_function(stacktop,"floatp",Fn_floatp,1);
  1461.   (void) make_module_function(stacktop,"floor",Fn_floor,1);
  1462.   (void) make_module_function(stacktop,"ceiling",Fn_ceiling,1);
  1463.   (void) make_module_function(stacktop,"sin",Fn_sin,1);
  1464.   (void) make_module_function(stacktop,"cos",Fn_cos,1);
  1465.   (void) make_module_function(stacktop,"exp",Fn_exp,1);
  1466.   (void) make_module_function(stacktop,"acos",Fn_acos,1);
  1467.   (void) make_module_function(stacktop,"asin",Fn_asin,1);
  1468.   (void) make_module_function(stacktop,"atan",Fn_atan,1);
  1469.   (void) make_module_function(stacktop,"atan2",Fn_atan2,2);
  1470.   (void) make_module_function(stacktop,"tan",Fn_tan,1);
  1471.   (void) make_module_function(stacktop,"acosh",Fn_acosh,1);
  1472.   (void) make_module_function(stacktop,"asinh",Fn_asinh,1);
  1473.   (void) make_module_function(stacktop,"atanh",Fn_atanh,1);
  1474.   (void) make_module_function(stacktop,"cosh",Fn_cosh,1);
  1475.   (void) make_module_function(stacktop,"sinh",Fn_sinh,1);
  1476.   (void) make_module_function(stacktop,"tanh",Fn_tanh,1);
  1477.   (void) make_module_function(stacktop,"log",Fn_log,-1);
  1478.  
  1479.   (void) make_module_function(stacktop,"quotient",Fn_quotient,2);
  1480.   (void) make_module_function(stacktop,"remainder",Fn_remainder,2);
  1481.   (void) make_module_function(stacktop,"modulo",Fn_remainder,2);
  1482.  
  1483.   generic_binary_lt 
  1484.     = make_wrapped_module_generic(stacktop,"binary-lt",2,Gf_binary_lt);
  1485.     add_root(&generic_binary_lt);
  1486.   (void) make_module_function(stacktop,"generic_binary_lt,Number,Number",
  1487.                   Md_binary_lt_Number,2
  1488.                   );
  1489.   (void) make_module_function(stacktop,"generic_binary_lt,Integer,Integer",
  1490.                   Md_binary_lt_Integer,2
  1491.                   );
  1492.   (void) make_module_function(stacktop,"<",Fn_lt,-1);
  1493.  
  1494.   generic_binary_gt 
  1495.     = make_wrapped_module_generic(stacktop,"binary-gt",2,Gf_binary_gt);
  1496.   add_root(&generic_binary_gt);
  1497.   (void) make_module_function(stacktop,"generic_binary_gt,Number,Number",
  1498.                   Md_binary_gt_Number,2
  1499.                   );
  1500.   (void) make_module_function(stacktop,"generic_binary_gt,Integer,Integer",
  1501.                   Md_binary_gt_Integer,2
  1502.                   );
  1503.   (void) make_module_function(stacktop,">",Fn_gt,-1);
  1504.  
  1505.   (void) make_module_function(stacktop,"<=",Fn_lt_or_equal,-1);
  1506.   (void) make_module_function(stacktop,">=",Fn_gt_or_equal,-1);
  1507.  
  1508.   (void) make_module_function(stacktop,"max",Fn_max,-1);
  1509.   (void) make_module_function(stacktop,"min",Fn_min,-1);
  1510.  
  1511.   (void) make_module_function(stacktop,"truncate",Fn_truncate,1);
  1512.   (void) make_module_function(stacktop,"round",Fn_round,1);
  1513.  
  1514.   (void) make_module_function(stacktop,"real-part",Fn_Real_Part,1);
  1515.   (void) make_module_function(stacktop,"imaginary-part",Fn_Imaginary_Part,1);
  1516.   (void) make_module_function(stacktop,"make-rectangular",Fn_Make_Rectangular,2);
  1517.  
  1518.   (void) make_module_function(stacktop,"numerator",Fn_Numerator,1);
  1519.   (void) make_module_function(stacktop,"denominator",Fn_Denominator,1);
  1520.   
  1521.   /* PAB added */
  1522.   (void) make_module_function(stacktop,"sqrt",Fn_sqrt,1);
  1523.   
  1524.   close_module();
  1525.  
  1526. }
  1527.